unit CustAppLittle;

interface

uses SysUtils, Classes;

type

  TCustomApplication = class(TObject)
  private
    FHelpFile: string;
    FOptionChar: Char;
    FCaseSensitiveOptions: Boolean;
    FStopOnException: Boolean;
    function GetEnvironmentVar(VarName: string): string;
    function GetExeName: string;
    function GetLocation: string;
  protected
    function GetConsoleApplication: boolean; virtual;
    function GetParams(Index: Integer): string; virtual;
    function GetParamCount: Integer; virtual;
  public
    // Extra methods.
    function FindOptionIndex(const S: string; var Longopt: Boolean): Integer;
    function GetOptionValue(const S: string): string; overload;
    function GetOptionValue(const C: Char; const S: string): string; overload;
    function HasOption(const S: string): Boolean; overload;
    function HasOption(const C: Char; const S: string): Boolean; overload;
    function CheckOptions(const ShortOptions: string; const Longopts: TStrings; Opts, NonOpts: TStrings): string; overload;
    function CheckOptions(const ShortOptions: string; const Longopts: TStrings): string; overload;
    function CheckOptions(const ShortOptions: string; const LongOpts: array of string): string; overload;
    function CheckOptions(const ShortOptions: string; const LongOpts: string): string; overload;
    constructor Create;
    // Delphi properties
    property ExeName: string read GetExeName;
    property HelpFile: string read FHelpFile write FHelpFile;
    // Extra properties
    property ConsoleApplication: Boolean read GetConsoleApplication;
    property Location: string read GetLocation;
    property Params[Index: integer]: string read GetParams;
    property ParamCount: Integer read GetParamCount;
    property EnvironmentVariable[envName: string]: string read GetEnvironmentVar;
    property OptionChar: Char read FoptionChar write FOptionChar;
    property CaseSensitiveOptions: Boolean read FCaseSensitiveOptions write FCaseSensitiveOptions;
    property StopOnException: Boolean read FStopOnException write FStopOnException;
  end;

implementation

{ TCustomApplication }

constructor TCustomApplication.Create;
begin
  FOptionChar := '-';
  FCaseSensitiveOptions := True;
  FStopOnException := False;
end;

function TCustomApplication.GetExeName: string;
begin
  Result := Paramstr(0);
end;

function TCustomApplication.GetEnvironmentVar(VarName: string): string;
begin
  Result := GetEnvironmentVariable(VarName);
end;

function TCustomApplication.GetLocation: string;
begin
  Result := ExtractFilePath(GetExeName);
end;

function TCustomApplication.GetParamCount: Integer;
begin
  Result := System.ParamCount;
end;

function TCustomApplication.GetParams(Index: Integer): string;
begin
  Result := ParamStr(Index);
end;

function TCustomApplication.GetConsoleApplication: boolean;
begin
  Result := IsConsole;
end;

function TCustomApplication.GetOptionValue(const S: string): string;
begin
  Result := GetoptionValue(#255, S);
end;

function TCustomApplication.GetOptionValue(const C: Char; const S: string): string;
var
  B: Boolean;
  I, P: integer;
  O: string;
begin
  Result := '';
  I := FindOptionIndex(C, B);
  if (I = -1) then
    I := FindoptionIndex(S, B);
  if (I <> -1) then
  begin
    if B then
    begin // Long options have form --option=value
      O := Params[I];
      P := Pos('=', O);
      if (P = 0) then
        P := Length(O);
      Delete(O, 1, P);
      Result := O;
    end
    else
    begin // short options have form '-o value'
      if (I < ParamCount) then
        Result := Params[I + 1];
    end;
  end;
end;

function TCustomApplication.HasOption(const S: string): Boolean;
var
  B: Boolean;
begin
  Result := FindOptionIndex(S, B) <> -1;
end;

function TCustomApplication.FindOptionIndex(const S: string; var Longopt: Boolean): Integer;
var
  SO, O: string;
  I, P: Integer;
begin
  if not CaseSensitiveOptions then
    SO := UpperCase(S)
  else
    SO := S;
  Result := -1;
  I := ParamCount;
  while (Result = -1) and (I > 0) do
  begin
    O := Params[i];
    if (Length(O) > 0) and (O[1] = FOptionChar) then
    begin
      Delete(O, 1, 1);
      LongOpt := (Length(O) > 0) and (O[1] = FOptionChar);
      if LongOpt then
      begin
        Delete(O, 1, 1);
        P := Pos('=', O);
        if (P <> 0) then
          O := Copy(O, 1, P - 1);
      end;
      if not CaseSensitiveOptions then
        O := UpperCase(O);
      if (O = SO) then
        Result := i;
    end;
    Dec(i);
  end;
end;

function TCustomApplication.HasOption(const C: Char; const S: string): Boolean;
var
  B: Boolean;
begin
  Result := (FindOptionIndex(C, B) <> -1) or (FindOptionIndex(S, B) <> -1);
end;

function TCustomApplication.CheckOptions(const ShortOptions: string; const Longopts: TStrings): string;
begin
  Result := CheckOptions(ShortOptions, LongOpts, nil, nil);
end;

resourcestring
  SErrInvalidOption = 'Invalid option at position %d: "%s"';
  SErrNoOptionAllowed = 'Option at position %d does not allow an argument: %s';
  SErrOptionNeeded = 'Option at position %d needs an argument : %s';

function TCustomApplication.CheckOptions(const ShortOptions: string; const Longopts: TStrings; Opts, NonOpts: TStrings): string;
var
  I, J, L, P: Integer;
  O, OV, SO: string;
  HaveArg: Boolean;
  function FindLongOpt(S: string): boolean;
  var
    I: integer;
  begin
    if CaseSensitiveOptions then
    begin
      I := LongOpts.Count - 1;
      while (I >= 0) and (LongOpts[i] <> S) do
        Dec(i);
    end
    else
    begin
      S := UpperCase(S);
      I := LongOpts.Count - 1;
      while (I >= 0) and (UpperCase(LongOpts[i]) <> S) do
        Dec(i);
    end;
    Result := (I <> -1);
  end;
begin
  if CaseSensitiveOptions then
    SO := Shortoptions
  else
    SO := LowerCase(Shortoptions);
  Result := '';
  I := 1;
  while (I <= ParamCount) and (Result = '') do
  begin
    O := Paramstr(I);
    if (Length(O) = 0) or (O[1] <> FOptionChar) then
    begin
      if Assigned(NonOpts) then
        NonOpts.Add(O)
    end
    else
    begin
      if (Length(O) < 2) then
        Result := Format(SErrInvalidOption, [i, O])
      else
      begin
        HaveArg := False;
        OV := '';
        // Long option ?
        if (O[2] = FOptionChar) then
        begin
          Delete(O, 1, 2);
          J := Pos('=', O);
          if J <> 0 then
          begin
            HaveArg := true;
            OV := O;
            Delete(OV, 1, J);
            O := Copy(O, 1, J - 1);
          end;
          // Switch Option
          if FindLongopt(O) then
          begin
            if HaveArg then
              Result := Format(SErrNoOptionAllowed, [I, O])
          end
          else
          begin // Required argument
            if FindLongOpt(O + ':') then
            begin
              if not HaveArg then
                Result := Format(SErrOptionNeeded, [I, O]);
            end
            else
            begin // Optional Argument.
              if not FindLongOpt(O + '::') then
                Result := Format(SErrInvalidOption, [I, O]);
            end;
          end;
        end
        else // Short Option.
        begin
          HaveArg := (I < ParamCount) and (Length(ParamStr(I + 1)) > 0) and (ParamStr(I + 1)[i] <> FOptionChar);
          if HaveArg then
            OV := Paramstr(I + 1);
          if not CaseSensitiveOptions then
            O := LowerCase(O);
          L := Length(O);
          J := 2;
          while (result = '') and (J <= L) do
          begin
            P := Pos(O[J], ShortOptions);
            if (P = 0) or (O[j] = ':') then
              Result := Format(SErrInvalidOption, [I, O[J]])
            else
            begin
              if (P < Length(ShortOptions)) and (Shortoptions[P + 1] = ':') then
              begin
                // Required argument
                Writeln('P ', P, ' J ', J, ' ', O[J], ' ', l, ' Havearg ', HaveArg);
                if ((P + 1) = Length(ShortOptions)) or (Shortoptions[P + 2] <> ':') then
                  if (J < L) or not haveArg then // Must be last in multi-opt !!
                    Result := Format(SErrOptionNeeded, [I, O[J]]);
                O := O[j]; // O is added to arguments.
              end;
            end;
            Inc(J);
          end;
          if HaveArg then
          begin
            Inc(I); // Skip argument.
            O := O[Length(O)]; // O is added to arguments !
          end;
        end;
        if HaveArg and (Result = '') then
          if Assigned(Opts) then
            Opts.Add(O + '=' + OV);
      end;
    end;
    Inc(I);
  end;
end;

function TCustomApplication.CheckOptions(const ShortOptions: string; const LongOpts: array of string): string;
var
  L: TStringList;
  I: Integer;
begin
  L := TStringList.Create;
  try
    for I := 0 to High(LongOpts) do
      L.Add(LongOpts[i]);
    Result := CheckOptions(ShortOptions, L);
  finally
    L.Free;
  end;
end;

function TCustomApplication.CheckOptions(const ShortOptions: string; const LongOpts: string): string;
const
  SepChars = ' '#10#13#9;
var
  L: TStringList;
  Len, I, J: Integer;
begin
  L := TStringList.Create;
  try
    I := 1;
    Len := Length(LongOpts);
    while I <= Len do
    begin
      while Isdelimiter(SepChars, LongOpts, I) do
        Inc(I);
      J := I;
      while (J <= Len) and not IsDelimiter(SepChars, LongOpts, J) do
        Inc(J);
      if (I <= J) then
        L.Add(Copy(LongOpts, I, (J - I)));
      I := J + 1;
    end;
    Result := CheckOptions(Shortoptions, L);
  finally
    L.Free;
  end;
end;

end.

